home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MOS / GRANULE.I < prev    next >
Encoding:
Text File  |  1994-03-16  |  23.7 KB  |  700 lines
  1. (*########################################################################
  2.                               S T O R A G E
  3.   ########################################################################
  4.  
  5.   Idee          : Johannes Leckebusch, Peter Sollich
  6.   Realisation   : Peter Sollich
  7.   Dynamic Heap  : Peter Hellinger
  8.  
  9.   ########################################################################
  10.  
  11.   16.03.94 TT   Verwendet nun kein TT-RAM mehr, weil die freeMap auf einen ein-
  12.                 zigen Bereich ausgelegt ist. Wollte man das TT-RAM mitnutzen,
  13.                 müßte 1. für die Berechnung der Maximalgröße der freeMap das
  14.                 TT-RAM mit einbezogen werden (s. Zuweisung 'MaxHeapSize') und
  15.                 2. die freeMap diesen zweiten Speicherbereich entsprechend
  16.                 berücksichtigen. Ein einfache Lösung wäre, einfach als
  17.                 Speicherobergrenze das MemTop vom TT-RAM zu nehmen, allerdings
  18.                 würden dann für die Lücke vom Ende d. ST-RAMs zum Beginn des
  19.                 TT-RAMs (können 8-14 MB sein) trotzdem Einträge in der FreeMap
  20.                 reserviert werden, was bis zu ca. 100 KB verschwendet.
  21.                 Umgekehrt könnte man auch einfach nur das TT-RAM verwenden,
  22.                 wenn vorhanden.
  23.  
  24.   19.01.94 TT   Die freemap wird nun nicht mehr zu weit (über allozierten
  25.                 Bereicht hinaus) gelöscht.
  26.   
  27.   18.12.90 TT   Noch eine Malloc-Erfolgsabfrage in CreateHeap vorgesehen
  28.   
  29.   12.12.90 TT   Super & Malloc geändert (kein Zugriff auf glob. 'a' mehr).
  30.                 OutOfMemory-Aufruf statt HALT.
  31.  
  32.   28.05.89 Hp   deallocate ist jetzt in der Lage nur ein Teil-Deallocate
  33.                 des Speicher-Blocks durchzuführen.
  34.  
  35.   26.05.89 Hp   Problem des "doppelten Lottchens" in deallocate gelöst.
  36.                 Stürzt nun nicht mehr bei bereits deallozierten Pointern ab.
  37.  
  38.   28.12.88 Hp   deallocate stürzt nicht mehr bei NIL-Pointern ab.
  39.            +    Allozierungs reihenfolge verändert. Dadurch das "Heaprest"-
  40.                 Problem gelöst. Siehe auch Kommentar in allocate.
  41.            +    Berechnung der freien bzw. belegten Bytes im Heap auf Bytes
  42.                 umgestellt. free liefert jetzt auch die Anzahl freier BYTES.
  43.            +    memAvail liefert nun die Anzahl aller freien BYTES sowohl
  44.                 im Heap, als auch im noch nicht allozierten Speicher -
  45.                 abzüglich der GEMDOS-Reserve von 64kb (Konstante GEMReserve)
  46.            +    In AppendHeap wird nun bei JEDER Fehlerbedingung das Dynamic-
  47.                 Flag FALSE geschaltet. (!!)
  48.                 
  49.   04.12.88 Hp   Initalisierung des Heaps beschleunigt.
  50.                 Markierung von Lisp-Blöcken durchgängig gemacht; läuft nun
  51.                 auch über AppendHeap.
  52.  
  53.   03.12.88 Hp   Zu früh gefreut: Storage läuft nicht. Warum? Nach endlosem
  54.                 Debugging habe ich zwei Fehler gefunden:
  55.                 1. Die Größe des Blocks der per AppendHeap angefordert
  56.                    wurde, wird nicht richtig gesetzt. Dadurch ist die
  57.                    Blockberechnung von DEALLOCATE katastrophal falsch.
  58.                    Warum es zunächst funktionierte ist mir schleierhaft.
  59.                 2. GEMDOS.Alloc liefert nicht NIL wenn kein Speicher mehr
  60.                    da, ist sondern NULL. AppendHeap konnte deshalb das
  61.                    Ende des Speichers nicht erkennen.
  62.  
  63.   28.11.88 Hp   Initialisierung für GESAMTEN Speicher eingeführt. Kann
  64.                 sonst zu Problemen führen wenn wir Blocks bekommen die
  65.                 nicht durch unsere freeMap abgedeckt werden.
  66.  
  67.   25.11.88 Hp   Bug in allocate beseitig. allocate testet nun BEVOR es nach
  68.                 einem Block sucht, ob der Heap überhaupt groß genug ist.
  69.                 Der G2E läuft jetzt einwandfrei. Damit müßten eigentlich
  70.                 alle schwerwiegenden Fehler behoben sein.
  71.  
  72.   23.11.88 Hp   Jubel! Heaptest lief einwandfrei! 3640 x 1000 Byte und an-
  73.                 schließend 1820 x 2000 Byte. Nun kommen die Härtetests.
  74.  
  75.   22.11.88 Hp   Heute fiel der Groschen: Es ist wieder einmal eines jener
  76.                 Dinge, die einem fast in die Nase zwicken, bevor man sie
  77.                 sieht. Also: Wir tarnen das Stückchen Speicher, daß wir
  78.                 in den Heap integrieren wollen als von ALLOCATE behandlet
  79.                 (korrekt gesetzte Größen, GranulesUsed richtig berechnet etc.
  80.                 largeSentinel erhält die neue Heapgröße) und lassen es von
  81.                 DEALLOCATE in den Heap integrieren... Physikalisch zusammen-
  82.                 hängende Speicherbereiche werden anhand der BitMap ermittelt
  83.                 und als größerer Block in den Heap integriert.
  84.  
  85.   20.11.88 Hp   Versuchsweise Implementierung von AppendHeap -> Bombenstimmung
  86.   
  87.   19.11.88 Hp   freeMap wird bei Modul-Initialisierung für den ganzen verfüg-
  88.                 baren Speicher angelegt -> dadurch Weg frei für eine dynamische
  89.                 Heap-Erweiterung.
  90.  
  91.   18.11.88 Hp   Massenweise Kommentare ergänzt.
  92.                 Bezeichner etwas entkryptisiert...
  93.                 Standard-Initalisierung bei Aufruf von ALLOCATE (@#!)
  94.  
  95.   08.08.87      Johannes Leckebusch / Peter Sollich
  96.                 Erstimplementation
  97.  
  98.   ########################################################################*)
  99.  
  100. IMPLEMENTATION MODULE Granule;
  101.  
  102. (* Idee         : Johannes Leckebusch, Peter Sollich    *)
  103. (* Realisation  : Peter Sollich                         *)
  104. (* Dynamic-Heap : Peter Hellinger                       *)
  105. (* Stand        : 05.10.90   Version für MM2            *)
  106.  
  107. (*$Y+*)
  108. (*$R- *) (* Range-Checks    *)
  109.  
  110. FROM SYSTEM IMPORT  ADDRESS, ASSEMBLER, CAST;
  111.  
  112. FROM SystemError IMPORT OutOfMemory;
  113.  
  114. FROM Block IMPORT Clear;
  115.  
  116.  
  117. CONST   cSetGrain =     LONGCARD(8);    (* Granule-Setgröße   *)
  118.         cMinHeapSize =  64;             (* Minimum-Heap       *)
  119.         cMaxHeapSize =  16777215;       (* 16 Megabyte maximaler Heap   *)
  120.         cMaxGranules =  1048575;        (* Maximale Anzahl der Granules *)
  121.         cBytesInSet =   131071;         (* Maximum Bytes im Set *)
  122.         GEMReserve =    010000H;        (* 64kb Restspeicher für GEM *)
  123.         cgrain =        16;
  124.         NULL =          ADDRESS(0);
  125.  
  126. TYPE    BlockPtr =      POINTER TO Block; (* Zeiger auf ein Element des Heaps *)
  127.         Block =         RECORD
  128.                          bigger: BlockPtr; (* Zeiger auf größere Blöcke (rechts) *)
  129.                          equal:  BlockPtr; (* Zeiger auf kleinere Blöcke (links) *)
  130.                          back:   BlockPtr; (* Zeiger auf den vorhergehenden Block *)
  131.                          size:   LONGCARD; (* Größe des Blocks *)
  132.                         END;
  133.  
  134.  
  135. TYPE    ByteSet =       SET OF [0..7]; (* Basistyp für das BitmapSet *)
  136.         mapSet =        ARRAY [0..cBytesInSet] OF ByteSet;
  137.  
  138.  
  139. VAR     root:           BlockPtr;     (* Die Wurzel unseres Baumes    *)
  140.         initialBlock:   BlockPtr;     (* Erster Block des Baumes      *)
  141.         largeSentinel:  BlockPtr;     (* Lezter Block im Heap         *)
  142.         freeMap:        POINTER TO mapSet;
  143.         lispMap:        POINTER TO mapSet;
  144.         GranulesUsed:   LONGCARD;     (* Wird vorerst nicht mehr benutzt *)
  145.         heapUsed:       LONGCARD;     (* Anzahl der benutzten Bytes   *)
  146.         heapStart:      ADDRESS;
  147.         heapSize:       LONGCARD;     (* Größe des Heap               *)
  148.         dynamic:        BOOLEAN;      (* Flag für Dynamic-Option      *)
  149.         defaultSize:    LONGCARD;     (* Standardgröße für Heaperweiterung *)
  150.         FreeMapSize:    LONGCARD;     (* Größe der Bitmap             *)
  151.         MaxHeapSize:    LONGCARD;     (* Maximale Größe des Heaps     *)
  152.         MemoryBottom:   ADDRESS;      (* Unteres Ende des Speichers   *)
  153.         PhysicalTop:    ADDRESS;      (* Oberes Ende des Speichers    *)
  154.  
  155.  
  156.  
  157. VAR a: ADDRESS;
  158.  
  159.  
  160.  
  161. PROCEDURE Malloc (bytes: LONGCARD): ADDRESS;
  162. VAR a: ADDRESS;
  163. BEGIN
  164.  ASSEMBLER
  165.   CLR.W   -(A7)         ; nur ST-RAM anfordern, kein TT-RAM
  166.   MOVE.L  bytes(A6),-(SP)
  167.   MOVE.W  #$44,-(SP)    ; Mxalloc() - nur bei Atari TT & Falcon verfügbar
  168.   TRAP    #1
  169.   TST.L   D0
  170.   BPL     ok2
  171.   ; falls Fehler bei mxalloc kam, es nochmal mit altem malloc probieren:
  172.   MOVE.W  #$48,(SP)    ; Malloc()
  173.   TRAP    #1
  174.  ok2:
  175.   ADDQ.L  #8,SP
  176.   TST.L   D0
  177.   BPL     ok
  178.   CLR.L   D0
  179.  ok:
  180.   MOVE.L  D0, a(A6)
  181.  END;
  182.  RETURN a;
  183. END Malloc;
  184.  
  185. PROCEDURE Super (VAR stack: ADDRESS);
  186. BEGIN
  187.  ASSEMBLER
  188.   MOVE.L  stack(A6),A0
  189.   MOVE.L  (A0), -(SP)
  190.   MOVE.W  #32, -(SP)
  191.   TRAP    #1
  192.   ADDQ.L  #6, SP
  193.   MOVE.L  stack(A6),A0
  194.   MOVE.L  D0,(A0)
  195.  END;
  196. END Super;
  197.  
  198. PROCEDURE AppendHeap (Amount: LONGCARD): BOOLEAN;
  199. (* fügt neuen Block in den Heap ein, FALSE wenn nicht möglich *)
  200.  
  201. VAR Block, b1:  BlockPtr;
  202.     adr:        ADDRESS;
  203.     lc:         LONGCARD;
  204. VAR l,g:        LONGCARD;
  205.     wasFree:    BOOLEAN;
  206.  
  207. BEGIN
  208.  
  209.  (* erst mal Testen ob soviel Speicher da ist *)
  210.  lc:= CAST (LONGCARD, Malloc (0FFFFFFFFH));
  211.  IF (lc > GEMReserve) THEN
  212.   DEC(lc, GEMReserve) (* Gemdos-Minimum reservieren *)
  213.  ELSE
  214.   dynamic:= FALSE; (* Speicher kleiner als GEMReserve -> nix geht mehr *)
  215.   RETURN FALSE;
  216.  END;
  217.  
  218.  IF lc < Amount THEN
  219.   Amount:=lc;
  220.   dynamic:=FALSE;
  221.   (* Kein Speicher mehr zur Verfügung -> AppendHeap darf nicht mehr
  222.    * aufgerufen werden, da sonst Restspeicher für GEM verbraten wird!
  223.    *)
  224.  END;
  225.  
  226.  (* Nur Vielfache von cgrain als Blockgröße zulassen *)
  227.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  228.  
  229.  (* Testen, ob Amount im gültigen Bereich *)
  230.  IF (Amount < cMinHeapSize) OR (Amount > MaxHeapSize) THEN
  231.   dynamic:= FALSE; RETURN FALSE;
  232.  END;
  233.  
  234.  (* Speicher abrufen *)
  235.  Block:= Malloc (Amount);
  236.  IF Block=NULL THEN
  237.   dynamic:=FALSE;
  238.   RETURN FALSE
  239.  END;
  240.  
  241.  INC(heapSize, Amount); (* neue Heapgröße berechnen *)
  242.  largeSentinel^.size:= heapSize + 1;
  243.  
  244.  (* Unseren neuen Block als von ALLOCATE behandelt tarnen  *)
  245.  (* 04.12.88: Wie hat das bloß jemals funktionieren können ??? *)
  246.  Block^.size:= Amount-(cgrain * 2);
  247.  b1:= (ADDRESS(Block)+ADDRESS(Block^.size))-ADDRESS(cgrain);
  248.  b1^.size:= Block^.size;
  249.  INC(heapUsed, Amount);  (* Zur Tarnung *)
  250.  
  251.  (* Nun wird der Block noch in der Bitmap als Belegt gekennzeichnet.
  252.   * Es genügt, das erste Bit zu setzen, da deallocate auch nur das
  253.   * erste Block-Bit in der freeMap testet.  Zeit ist Geld!
  254.   *)
  255.  l:= CAST (LONGCARD, CAST (ADDRESS, Block) - MemoryBottom) DIV cgrain;
  256.  g:= Amount DIV cgrain;
  257.  EXCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  258.  
  259.  (* Nun muß auch der phys. linke Nachbar temporär als belegt gekennzeichnet
  260.   * werden, damit nicht versucht wird, auf den "Block" vor diesem neu
  261.   * angelegten Speicherbereich zuzugreifen. TT 19.01.94
  262.   *)
  263.  wasFree:= SHORT((l-1) MOD cSetGrain) IN freeMap^[(l-1) DIV cSetGrain];
  264.  EXCL(freeMap^[(l-1) DIV cSetGrain],SHORT((l-1) MOD cSetGrain));
  265.  
  266.  DEALLOCATE (Block, Amount);
  267.  
  268.  IF wasFree THEN
  269.   INCL(freeMap^[(l-1) DIV cSetGrain],SHORT((l-1) MOD cSetGrain));
  270.  END;
  271.  
  272.  RETURN TRUE;
  273. END AppendHeap;
  274.  
  275.  
  276. PROCEDURE ALLOCATE (VAR Addr: ADDRESS; Amount: LONGCARD);
  277. VAR Block,b : BlockPtr;
  278.     b1,b2,b3: BlockPtr;
  279.     l,g     : LONGCARD;
  280.     m       : LONGCARD; (* für Testzwecke *)
  281.     i       : INTEGER;  (* für createheap *)
  282. BEGIN
  283.  
  284.  Addr:= NIL; (* Na denn... *)
  285.  
  286.  (* Wenn nicht installiert, muß der Heap initialisiert werden *)
  287.  IF root = NIL THEN
  288.   IF (Amount>=defaultSize) THEN  i:= CreateHeap (Amount+defaultSize);
  289.                            ELSE  i:= CreateHeap (defaultSize);
  290.   END;
  291.   IF i < 0 THEN RETURN; END;
  292.   (* hier kann nur 0 oder -1 zurückkommen, da root=NIL *)
  293.  END;
  294.  
  295.  IF (Amount > heapSize) THEN (* Grmpfft! Siehe Bugnote 25.11.88 *)
  296.   IF dynamic THEN
  297.    IF NOT AppendHeap (Amount) THEN RETURN END;
  298.   ELSE
  299.    RETURN;
  300.   END;
  301.  END;
  302.  
  303.  Block:= root; (* Laufzeiger auf Beginn des Heap-Baumes *)
  304.  
  305.  (* Nur Vielfache von cgrain als Blockgröße zulassen *)
  306.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  307.  
  308.  (* Suche nach einem Block größer oder gleich dem Angeforderten *)
  309.  REPEAT Block:= Block^.bigger UNTIL Block^.size>=Amount;
  310.           (* !TT 19.01.94: vormals: Block^.size>Amount *)
  311.  
  312.  IF Block^.size>heapSize THEN (* Heapoverflow! *)
  313.   IF dynamic THEN
  314.    IF NOT AppendHeap (defaultSize) THEN RETURN END; (* nichts geht mehr *)
  315.    ALLOCATE (Addr, Amount);
  316.   ELSE
  317.    RETURN;
  318.   END;
  319.   RETURN;
  320.  END;
  321.  
  322.  b1:= Block^.back; (* b1 = vorhergehender Block *)
  323.  
  324.  IF Block^.size=Amount THEN
  325.   (* Block hat gleiche Größe wie angefordert, das ist einfach *)
  326.   
  327.   (*!TT 19.01.94
  328.    *  Hier fehlte Zuweisung von "Addr". Allerdings kam wg. der fehlerhaften
  329.    *  Suchschleife (es wurde nur nach größeren freien Blocks gesucht) nie
  330.    *  dazu, daß dieser Code ausgeführt wurde. Hoffentlich klappt's nun so.
  331.    *)
  332.   Addr:= Block;
  333.   
  334.   (*-- Block aus der Liste lösen und Liste restaurieren --*)
  335.   b2:= Block^.equal;
  336.   b3:= Block^.bigger;
  337.   IF b2=NIL THEN
  338.    b1^.bigger:= b3;
  339.    b3^.back:= b1;
  340.   ELSE
  341.    b1^.bigger:= b2;
  342.    b2^.bigger:= b3;
  343.    b2^.back:= b1;
  344.    b3^.back:= b2;
  345.   END;
  346.  
  347.  ELSE (* Block ist größer als angefordert -> nu wirds kompliziert *)
  348.  
  349.  (* In Verbindung mit der dynamischen Erweiterungsmöglichkeit des Heaps
  350.   * ergibt sich hier ein gar nicht so leicht aufzudeckender Fehler:
  351.   *
  352.   * Der allozierte Speicher wird am OBEREN Ende des gefundenen Blocks
  353.   * abgezweigt. Hierdurch entsteht der Effekt, daß die Daten in UMGE-
  354.   * kehrter Reihenfolge im Heap stehen - also die zuerst abgelegten Daten
  355.   * auf höheren Adressen als die zuletzt abgelegten. Der Heap wächst
  356.   * gewissermaßen "nach unten".
  357.   *
  358.   * Wird nun mittels AppendHeap ein neuer Block in den Heap integriert,
  359.   * wird er in aller Regel eine höhere Adresse als der bereits bestehende
  360.   * Heap haben, also im Speicher weiter "hinten" liegen.
  361.   *
  362.   * Da der oberste Block des bereits bestehenden Heaps auch in aller Regel
  363.   * belegt sein wird (er wird ja schließlich als erster alloziert) kann
  364.   * deallocate den neuen Block nicht mit dem Rest des bestehenden Heaps
  365.   * verschmelzen - der Rest steht ja am BEGINN des Blocks, nicht am Ende
  366.   * wie es notwendig wäre.
  367.   *
  368.   * So können Blöcke entstehen, die nicht mehr durchs Programm allozierbar
  369.   * sind, da sie einfach zu klein sind. Je nachdem, wie die durchschnittliche
  370.   * Blockgröße aussieht, kann so ein Rest zwischen 1 und 100 Kilobyte
  371.   * entstehen (bei einem freien Speicher von ca 3.5 Mb).
  372.   *
  373.   * Ich habe versucht diesen Fehler auszumerzen, indem ich die Allozierungs-
  374.   * reihenfolge geändert habe. Der Rest-Heap sollte nun am Ende des Blocks
  375.   * stehen und sich mit dem neuen Block verschmelzen lassen.
  376.   *
  377.   * Hp 25.12.88
  378.   *)
  379.  
  380.   Addr:= Block; (* die halbe Miete hätten wir... *)
  381.  
  382.   (*-- Block aus Liste nehmen und Liste restaurieren --*)
  383.   b2:= Block^.equal;
  384.   b3:= Block^.bigger;
  385.   IF b2 = NIL THEN
  386.    b1^.bigger:= b3;
  387.    b3^.back:= b1;
  388.   ELSE
  389.    b1^.bigger:= b2;
  390.    b2^.bigger:= b3;
  391.    b2^.back:= b1;
  392.    b3^.back:= b2;
  393.   END;
  394.  
  395.   (* Block-Pointer "nach oben" verschieben *)
  396.   b:= ADDRESS(Block) + ADDRESS(Amount);
  397.   b^.bigger:= Block^.bigger;
  398.   b^.equal := Block^.equal;
  399.   b^.back  := Block^.back;
  400.   b^.size  := Block^.size - Amount;
  401.   Block:= b;
  402.  
  403.   (* Nun suchen wir ein trautes Plätzchen für den Rest unseres Blocks *)
  404.  
  405.   b2:= root;
  406.   REPEAT b2:= b2^.bigger UNTIL b2^.size>=Block^.size;
  407.   (* b2 zeigt auf einen Block größer oder gleich unseres Blockrestes *)
  408.  
  409.   (* Block an neuer Stelle einfügen *)
  410.   b1:= b2^.back;
  411.   b1^.bigger:= Block;
  412.   Block^.back:= b1;
  413.   b2^.back:= Block;
  414.   IF b2^.size>Block^.size THEN
  415.    (* Block zwischen b1 und b2 einfügen *)
  416.    Block^.bigger:= b2;
  417.    Block^.equal := NIL;
  418.   ELSE
  419.    (* Block nach b2 einfügen *)
  420.    b3:= b2^.bigger;
  421.    Block^.bigger:= b3;
  422.    Block^.equal:= b2;
  423.    b3^.back:= Block;
  424.   END;
  425.  
  426.   (* oberes Ende des Blocks berechnen *)
  427.   b2:= (CAST (ADDRESS, Block) + CAST (ADDRESS, Block^.size)) - CAST (ADDRESS, cgrain);
  428.   b2^.size:= Block^.size;
  429.  END (* IF Block^.Amount = Amount *);
  430.  
  431.  (* Nun wird der Block noch in der Bitmap als Belegt gekennzeichnet *)
  432.  l:= CAST (LONGCARD, Addr-MemoryBottom) DIV cgrain;
  433.  g:= Amount DIV cgrain;
  434.  INC(heapUsed,Amount);
  435.  REPEAT
  436.   EXCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  437.   INC(l); DEC(g);
  438.  UNTIL g=0;
  439.  
  440.  (* Uff... *)
  441. END ALLOCATE;
  442.  
  443.  
  444. PROCEDURE Shrink (VAR Addr: ADDRESS; Amount: LONGCARD; VAR new: LONGCARD);
  445. VAR newAddr   : ADDRESS;
  446.     newAmount : LONGCARD;
  447. BEGIN
  448.  IF Addr # NIL THEN
  449.   INC (Amount, (cgrain-1) - (Amount+ (cgrain-1)) MOD cgrain);
  450.   INC (new, (cgrain-1) - (new + (cgrain-1)) MOD cgrain);
  451.   IF (new > Amount) THEN
  452.    DEALLOCATE (Addr, Amount);
  453.   ELSE
  454.    newAddr:= Addr + ADDRESS (new);
  455.    newAmount:= Amount - new;
  456.    DEALLOCATE (newAddr, newAmount);
  457.   END;
  458.  END;
  459. END Shrink;
  460.  
  461.  
  462. PROCEDURE DEALLOCATE (VAR Addr: ADDRESS; Amount: LONGCARD);
  463. VAR  s,b,b1,b2,b3 : BlockPtr;
  464.      l,r,g        : LONGCARD;
  465. BEGIN
  466.  
  467.  IF Addr=NIL THEN RETURN END; (* gibt sonst Bömbchen *)
  468.  
  469.  (* Nur Vielfaches von cgrain als Größe zulassen *)
  470.  INC(Amount,(cgrain-1) - (Amount+(cgrain-1)) MOD cgrain);
  471.  
  472.  (* Schutz vor Doppelten Pointern *)
  473.  l:= CAST (LONGCARD, (Addr-MemoryBottom) DIV cgrain);
  474.  IF (SHORT(l MOD cSetGrain) IN ByteSet(freeMap^[l DIV cSetGrain])) THEN
  475.   Addr:= NIL; HALT; RETURN; (* Doppelter Pointer *)
  476.  END;
  477.  
  478.  (* Block in der Bitmap als frei kennzeichnen *)
  479.  (* l:= CAST (LONGCARD, (Addr-MemoryBottom) DIV cgrain);  Ist hier überflüssig *)
  480.  g:= Amount DIV cgrain;
  481.  DEC(heapUsed,Amount);
  482.  r:= l;
  483.  REPEAT
  484.   INCL(freeMap^[r DIV cSetGrain],SHORT(r MOD cSetGrain));
  485.   INC(r); DEC(g)
  486.  UNTIL g=0;
  487.  
  488.  s:= root; (* Start des Heap *)
  489.  b:= Addr; (* Adresse des Blocks *)
  490.  
  491.  (* physikalisch Rechten Nachbar in der Bitmap auf Frei testen *)
  492.  IF SHORT(r MOD cSetGrain) IN ByteSet(freeMap^[r DIV cSetGrain]) THEN
  493.  
  494.   b:= CAST (ADDRESS, b) + CAST (ADDRESS, Amount); (* Adresse des Blocks berechnen *)
  495.   INC (Amount, b^.size); (* Blockgröße zu der Unseren addieren *)
  496.  
  497.   (* Die Zeiger der beiden Blöcke verküpfen *)
  498.   b1:= b^.back; b2:= b^.equal;
  499.   IF b1^.size=b^.size THEN
  500.    b1^.equal:= b2;
  501.    IF b2#NIL THEN b2^.back:= b1 END;
  502.   ELSE
  503.    b3:= b^.bigger; s:= b3;
  504.    IF b2 = NIL THEN
  505.     b1^.bigger:= b3; b3^.back:= b1;
  506.    ELSE
  507.     b1^.bigger:= b2; b2^.bigger:= b3; b2^.back:= b1; b3^.back:= b2;
  508.    END;
  509.   END;
  510.   b:= Addr;
  511.  
  512.  END; (* IF SHORT *)
  513.  
  514.  (* physikalisch Linken Nachbar in der Bitmap auf Frei testen *)
  515.  IF SHORT((l-1) MOD cSetGrain) IN ByteSet(freeMap^[(l-1) DIV cSetGrain]) THEN
  516.   b1:= CAST (ADDRESS, b) - cgrain;
  517.   b:= Addr - CAST (ADDRESS, b1^.size); (* Startadresse des linken Blocks *)
  518.   INC(Amount,b^.size);
  519.   b1:=b^.back; b2:= b^.equal;
  520.  
  521.   IF b1^.size=b^.size THEN
  522.    b1^.equal:= b2;
  523.    IF b2#NIL THEN b2^.back:= b1 END;
  524.   ELSE
  525.    b3:= b^.bigger;
  526.    IF s^.size<b3^.size THEN s:= b3 END;
  527.    IF b2=NIL THEN
  528.     b1^.bigger:= b3; b3^.back:= b1;
  529.    ELSE
  530.     b1^.bigger:= b2; b2^.bigger:= b3; b2^.back:= b1; b3^.back:= b2;
  531.    END (* IF b2=NIL *);
  532.   END (* IF b1^.Amount *);
  533.  
  534.  END (* IF l - 1 *);
  535.  
  536.  b^.size:= Amount;  b1:= CAST (ADDRESS, b) + CAST (ADDRESS, Amount) - cgrain;
  537.  b1^.size:= Amount; b2:= s;
  538.  WHILE b2^.size<Amount DO b2:=b2^.bigger END;
  539.  b1:= b2^.back; b1^.bigger:= b; b^.back:= b1; b2^.back:= b;
  540.  IF b2^.size>Amount THEN (* insert b between b1 and b2 *)
  541.   b^.bigger:= b2; b^.equal:= NIL;
  542.  ELSE (* insert b above b2 *)
  543.   b3:= b2^.bigger; b^.bigger:= b3; b^.equal:= b2; b3^.back:= b;
  544.  END (* IF b2^.size *);
  545.  
  546.  Addr:= NIL; (* Schwitz... *)
  547.  
  548. END DEALLOCATE;
  549.  
  550.  
  551. PROCEDURE CreateHeap (Amount: LONGCARD): INTEGER;
  552. VAR smallSentinel: BlockPtr;
  553.     i,l,g        : LONGCARD;
  554.     a            : ADDRESS;  (*21.12.88 Hp*)
  555. BEGIN
  556.  
  557.  (* Fehler, wenn Heap schon existiert *)
  558.  IF root # NIL THEN RETURN -2 END;
  559.  
  560.  (* Mal sehen was so im Speicher rumliegt *)
  561.  l:= CAST (LONGCARD, Malloc (0FFFFFFFFH));
  562.  IF l <= GEMReserve THEN RETURN -1 END; (*19.01.94 TT*)
  563.  DEC(l, GEMReserve);
  564.  
  565.  (* Bereich testen und Heapsize korrigieren *)
  566.  INC(Amount,(cgrain-1)-(Amount+(cgrain-1)) MOD cgrain);
  567.  IF l < Amount THEN Amount:= l; END;
  568.  IF (Amount < cMinHeapSize) OR (Amount>l) THEN RETURN -1; END;
  569.  
  570.  (* Speicher anfordern *)
  571.  heapStart:= Malloc (Amount);
  572.  IF heapStart = NULL THEN
  573.    RETURN -1
  574.  END;
  575.  
  576.  heapSize:= Amount;
  577.  
  578.  smallSentinel:= heapStart;             (* unteres Ende des Heaps *)
  579.  largeSentinel:= heapStart+cgrain;      (* Zeiger auf obere Ende des Heap *)
  580.  initialBlock := heapStart+cgrain*2;    (* Erster Block des Heap *)
  581.  
  582.  (* "kleinen Wächter" initalisieren *)
  583.  WITH smallSentinel^ DO
  584.   bigger:= initialBlock;
  585.   equal := NIL;
  586.   back  := NIL;
  587.   size  :=   0;
  588.  END;
  589.  
  590.  (* "großen Wächter" initialisieren *)
  591.  WITH largeSentinel^ DO
  592.   bigger:= NIL;
  593.   equal := NIL;
  594.   back  := initialBlock;
  595.   size  := heapSize+1;
  596.   (* Aktuelle Heapgröße +1. So wird in allocate das Ende des Heaps erkannt. *)
  597.  END;
  598.  
  599.  (* Ersten Block intialisieren *)
  600.  WITH initialBlock^ DO
  601.   bigger:= largeSentinel;
  602.   equal := NIL;
  603.   back  := smallSentinel;
  604.   size  := Amount-(cgrain * 2);
  605.   DEC(size,size MOD cgrain);
  606.  END;
  607.  
  608.  heapUsed:= cgrain * 2;
  609.  
  610.  root:= smallSentinel;
  611.  
  612.  (* Heap in der Bitmap als frei kennzeichnen *)
  613.  l:= CAST (LONGCARD, (heapStart + CAST (ADDRESS, cgrain * 2)) - MemoryBottom) DIV cgrain;
  614.  g:= Amount DIV cgrain;
  615.  REPEAT
  616.   INCL(freeMap^[l DIV cSetGrain],SHORT(l MOD cSetGrain));
  617.   INC(l); DEC(g);
  618.  UNTIL g=0;
  619.  
  620.  (* Kennzeichnet unteres Ende des Heap *)
  621.  EXCL(freeMap^[0],1);
  622.  
  623.  RETURN 0;
  624. END CreateHeap;
  625.  
  626.  
  627. PROCEDURE Free(): LONGCARD;
  628. BEGIN
  629.  RETURN heapSize - heapUsed;
  630. END Free;
  631.  
  632.  
  633. PROCEDURE Dynamic (dyn: BOOLEAN);
  634. BEGIN
  635.  dynamic:= dyn;
  636. END Dynamic;
  637.  
  638.  
  639. PROCEDURE SetDefaultSize (size: LONGCARD);
  640. BEGIN
  641.  defaultSize:= size;
  642. END SetDefaultSize;
  643.  
  644.  
  645. PROCEDURE MemAvail(): LONGCARD;
  646. VAR a: ADDRESS;
  647.     l: LONGCARD;
  648. BEGIN
  649.  a:= Malloc (0FFFFFFFFH);
  650.  RETURN (heapSize + LONGCARD(a)) - (heapUsed + GEMReserve);
  651. END MemAvail;
  652.  
  653.  
  654. VAR     c:              LONGCARD;
  655.         x:              POINTER TO LONGCARD;
  656.         y:              POINTER TO CHAR;
  657.         phystop[042EH]: ADDRESS;        (* Systemvariable *)
  658.         membot[0432H]:  ADDRESS;        (* Systemvariable *)
  659.  
  660. BEGIN
  661.  
  662.  dynamic:=      TRUE;          (* Dynamic-Option gewählt       *)
  663.  defaultSize:=  010000H;       (* 64Kb Default Heapsize        *)
  664.  GranulesUsed:= 0;             (* Noch kein Granule gebraucht  *)
  665.  heapUsed:=     0;             (* Noch kein Byte belegt        *)
  666.  root:=         NIL;           (* Heap ist leer                *)
  667.  
  668.  (* maximale Speichergröße feststellen *)
  669.  a:= 0; Super(a);
  670.  PhysicalTop:=  phystop;
  671.  MemoryBottom:= membot;
  672.  Super(a);
  673.  
  674.  (* Maximale Größe des freien Speichers *)
  675.  MaxHeapSize:= CAST (LONGCARD, PhysicalTop - MemoryBottom);
  676.  
  677.  (* Größe der Bitmap berechnen, sie wird für den gesamten theoretisch
  678.   * verfügbaren Speicher ausgelegt. *)
  679.  FreeMapSize:= MaxHeapSize DIV (cgrain * cSetGrain);
  680.  INC(FreeMapSize);
  681.  
  682.  (* Speicher anfordern *)
  683.  freeMap:= Malloc(FreeMapSize);
  684.  IF (freeMap = NULL) THEN OutOfMemory END;
  685.  
  686.  (* Bitmap löschen. Geht so schneller *)
  687.  (* 19.01.94 TT: war sowieso fehlerhaft (FOR c:=0 mußte c:=1 heißen)
  688.   *   - nun gleich durch schnelleres Block.Clear ersetzt *)
  689.  (*
  690.    x:= CAST (ADDRESS, freeMap);
  691.    FOR c:=1 TO (FreeMapSize DIV 4) DO x^:=0; INC(x,4); END;
  692.    y:= CAST (ADDRESS, x);
  693.    FOR c:=1 TO (FreeMapSize MOD 4) DO y^:=0C; INC(y); END;
  694.  *)
  695.  Clear (freeMap, FreeMapSize);
  696.  
  697. END Granule.
  698. ə
  699. (* $FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$0000200F$FFE520B8$00005C77$FFE520B8$00004A78$FFE520B8$FFE520B8$FFE520B8$FFE520B8$00004272$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8$FFE520B8Ç$0000200BT.......T.......T.......T.......T.......T.......T.......T.......T.......T.......$00002091$00001FD1$00001FBB$00001FD6$00002096$000020B4$0000200F$000020B4$00002080$0000200B$00005A0A$00002019$000020CD$000020BC$00001FC4$FFE5C27A¿ÇÇ*)
  700.